home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trgred.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  17.0 KB  |  514 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module trgred)
  13.  
  14. (DECLARE-top (GENPREFIX PS)
  15.      (FIXNUM %N %NN)
  16.      (NOTYPE (SIN^N FIXNUM) (COS^N FIXNUM) (SINH^N FIXNUM)
  17.          (COSH^N FIXNUM) (CS^N FIXNUM))
  18.      (*LEXPR $GCD $DIVIDE $RATSIMP $FACTOR)
  19.      (SPECIAL VAR *N *A *SP1LOGF SPLIST *VAR USEXP $VERBOSE ANS *TRIGRED
  20.           *NOEXPAND SC^NDISP *LIN *TRIG LAWS TRIGLAWS HYPERLAWS
  21.           $TRIGEXPAND TRIGBUCKETS HYPERBUCKETS HALF%PI
  22.           TRANS-LIST-PLUS $RATPRINT $KEEPFLOAT))
  23.  
  24. (load-macsyma-macros rzmac)
  25.  
  26.  
  27. ;The Trigreduce file contains a group of routines which can be used to
  28. ;make trigonometric simplifications of expressions.  The bulk of the 
  29. ;routines here involve the reductions of products of sin's and cos's.
  30. ;
  31. ;    *TRIGRED    indicates that the special simplifications for
  32. ;            $TRIGREDUCE are to be used.
  33. ;    *NOEXPAND    indicates that trig functions of sums of 
  34. ;            angles are not to be used.
  35.  
  36. (DEFMFUN $TRIGREDUCE N
  37.  (LET ((*TRIGRED T) (*NOEXPAND T) VAR $TRIGEXPAND $VERBOSE $RATPRINT)
  38.       (COND ((= N 2) (SETQ VAR (ARG 2)))
  39.         ((= N 1) (SETQ VAR '*NOVAR))
  40.         (T (merror "Wrong number of args to TRIGREDUCE")))
  41.       (GCDRED (SP1 (ARG 1)))))
  42.  
  43. (DEFUN SP1 (E)
  44.     (COND ((ATOM E) E)
  45.       ((EQ (CAAR E) 'MPLUS)
  46.        (DO ((L TRANS-LIST-PLUS (CDR L)) (A))
  47.            ((NULL L) (M+L (MAPCAR 'SP1 (CDR E))))
  48.            (AND (SETQ A (M2 E (CAAR L) NIL))
  49.             (RETURN (SP1 (SCH-REPLACE A (CADAR L)))))))
  50.       ((EQ (CAAR E) 'MTIMES)
  51.        (SP1TIMES E))
  52.       ((EQ (CAAR E) 'MEXPT)
  53.        (SP1EXPT (SP1 (CADR E)) (SP1 (CADDR E))))
  54.       ((EQ (CAAR E) '%LOG)
  55.        (SP1LOG (SP1 (CADR E))))
  56.       ((MEMQ (CAAR E) '(%COS %SIN %TAN %COT %SEC %CSC
  57.                 %COSH %SINH %TANH %COTH %SECH %CSCH))
  58.        (SP1TRIG (LIST (CAR E) (let* ((*NOEXPAND T)) (SP1 (CADR E))))))
  59.       ((MEMQ (CAAR E) '(%ASIN %ACOS %ATAN %ACOT %ASEC %ACSC
  60.                 %ASINH %ACOSH %ATANH %ACOTH %ASECH %ACSCH))
  61.        (SP1ATRIG (CAAR E) (let* ((*NOEXPAND T)) (SP1 (CADR E)))))
  62.       ((EQ (CAAR E) 'MRAT) (SP1 (RATDISREP E)))
  63.       ((MBAGP E) (CONS (CAR E) (MAPCAR #'SP1 (CDR E))))
  64.       ((EQ (CAAR E) '%INTEGRATE)
  65.        (LIST* '(%INTEGRATE) (SP1 (CADR E)) (CDDR E)))
  66.       (T E))) 
  67.  
  68. (SETQ TRANS-LIST-PLUS
  69. '( (((MPLUS) ((COEFFPT) (C TRUE) ((MEXPT) ((%TAN) (X TRUE)) 2))
  70.          (VAR* (UVAR) C))   
  71.     ((MTIMES) C ((MEXPT) ((%SEC) X) 2)))
  72.    (((MPLUS) ((COEFFPT) (C TRUE) ((MEXPT) ((%COT) (X TRUE)) 2))
  73.          (VAR* (UVAR) C))
  74.     ((MTIMES) C ((MEXPT) ((%CSC) X) 2)))
  75.    (((MPLUS) ((COEFFPT) (C TRUE) ((MEXPT) ((%TANH) (X TRUE)) 2))
  76.          ((MTIMES) -1 (VAR* (UVAR) C)))
  77.     ((MTIMES) -1 C ((MEXPT) ((%SECH) X) 2)))
  78.    (((MPLUS) ((COEFFPT) (C TRUE) ((MEXPT) ((%COTH) (X TRUE)) 2))
  79.          ((MTIMES) -1 (VAR* (UVAR) C)))
  80.     ((MTIMES) C ((MEXPT) ((%CSCH) X) 2))) ))
  81.  
  82. (DEFUN TRIGFP (E) (OR (AND (NOT (ATOM E)) (TRIGP (CAAR E))) (EQUAL E 1)))
  83.  
  84. (DEFUN GCDRED (E)
  85.     (COND ((ATOM E) E)
  86.       ((EQ (CAAR E) 'MPLUS) (M+L (MAPCAR 'GCDRED (CDR E))))
  87.       ((EQ (CAAR E) 'MTIMES)
  88.        (let* ((NN
  89.          '(1))( ND '(1))( GCD NIL))
  90.         (DO ((E (CDR E) (CDR E)))
  91.             ((NULL E)
  92.              (SETQ NN (M*L NN) ND (M*L ND)))
  93.             (COND ((AND (MEXPTP (CAR E))
  94.                 (OR (SIGNP L (CADDAR E))
  95.                     (AND (MTIMESP (CADDAR E))
  96.                      (SIGNP L (CADR (CADDAR E))))))
  97.                (SETQ ND (CONS (M^ (CADAR E) (M- (CADDAR E))) ND)))
  98.               ((RATNUMP (CAR E))
  99.                (SETQ NN (CONS (CADAR E) NN)
  100.                  ND (CONS (CADDAR E) ND)))
  101.               ((SETQ NN (CONS (CAR E) NN)))))
  102.         (COND ((EQUAL ND 1) NN)
  103.               ((EQUAL (SETQ GCD ($GCD NN ND)) 1) E)
  104.               ((DIV* (CADR ($DIVIDE NN GCD))
  105.                  (CADR ($DIVIDE ND GCD)))))))
  106.       (T E)))
  107.  
  108. (DEFUN SP1TIMES (E)
  109.   (let* ((FR
  110.    NIL)( G '(1))( TRIGBUCKETS NIL)( HYPERBUCKETS NIL)( TR NIL)( HYP NIL)( *LIN '(0)))
  111.     (DO ((E (CDR E) (CDR E)))
  112.     ((NULL E) (SETQ G (MAPCAR 'SP1 G)))
  113.     (COND ((OR (MNUMP (CAR E))
  114.            (AND (NOT (EQ VAR '*NOVAR)) (FREE (CAR E) VAR)))
  115.            (SETQ FR (CONS (CAR E) FR)))
  116.           ((ATOM (CAR E)) (SETQ G (CONS (CAR E) G)))
  117.           ((OR (TRIGFP (CAR E))
  118.            (AND (EQ (CAAAR E) 'MEXPT) (TRIGFP (CADAR E))))
  119.            (SP1ADD (CAR E)))
  120.           ((SETQ G (CONS (CAR E) G)))))
  121.     (MAPCAR #'(LAMBDA (Q)  (SP1SINCOS Q T)) TRIGBUCKETS)
  122.     (MAPCAR #'(LAMBDA (Q) (SP1SINCOS Q NIL)) HYPERBUCKETS)
  123.     (SETQ FR (CONS (M^ (1//2) (M+L *LIN)) FR)
  124.       *LIN NIL)
  125.     (SETQ TR (CONS '* (MAPCAN 'SP1UNTREP TRIGBUCKETS)))
  126.     (SETQ G (NCONC (SP1TLIN TR T) (SP1TPLUS *LIN T) G)
  127.       *LIN NIL)
  128.     (SETQ HYP (CONS '* (MAPCAN 'SP1UNTREP HYPERBUCKETS)))
  129.     (SETQ G (NCONC (SP1TLIN HYP NIL) (SP1TPLUS *LIN NIL) G))
  130.     (SETQ G ($EXPAND (let* (($KEEPFLOAT T)) ($RATSIMP (CONS '(MTIMES) G)))))
  131.     (COND ((MTIMESP G) (SETQ G (MAPCAR 'SP1 (CDR G))))
  132.       ((SETQ G (LIST (SP1 G)))))
  133.     (M*L (CONS 1 (NCONC G FR (CDR TR) (CDR HYP))))))
  134.  
  135. (SETQ TRIGLAWS
  136. '(* %SIN (* %COT %COS %SEC %TAN) %COS (* %TAN %SIN %CSC %COT)
  137.     %TAN (* %COS %SIN %CSC %SEC) %COT (* %SIN %COS %SEC %CSC)
  138.     %SEC (* %SIN %TAN %COT %CSC) %CSC (* %COS %COT %TAN %SEC)))
  139.  
  140. (SETQ HYPERLAWS
  141. '(* %SINH (* %COTH %COSH %SECH %TANH) %COSH (* %TANH %SINH %CSCH %COTH)
  142.     %TANH (* %COSH %SINH %CSCH %SECH) %COTH (* %SINH %COSH %SECH %CSCH)
  143.     %SECH (* %SINH %TANH %COTH %CSCH) %CSCH (* %COSH %COTH %TANH %SECH)))
  144.  
  145. (DEFUN SP1TLIN (L *TRIG) (SP1TLIN1 L))
  146.  
  147. (DEFUN SP1TLIN1 (L)
  148.     (COND ((NULL (CDR L)) NIL)
  149.       ((AND (EQ (CAAADR L) 'MEXPT)
  150.         (INTEGERP (CADDR (CADR L)))
  151.          (MEMQ (CAAADR (CADR L))
  152.               (IF *TRIG '(%SIN %COS) '(%SINH %COSH))))
  153.        (CONS (FUNCALL (CDR (ASSQ (CAAADR (CADR L)) SC^NDISP))
  154.               (CADDR (CADR L)) (CADADR (CADR L)))
  155.          (SP1TLIN1 (RPLACD L (CDDR L)))))
  156.       ((MEMQ (CAAADR L) (IF *TRIG '(%SIN %COS) '(%SINH %COSH)))
  157.        (SETQ *LIN (CONS (CADR L) *LIN))
  158.        (SP1TLIN1 (RPLACD L (CDDR L))))
  159.       ((SP1TLIN1 (CDR L)))))
  160.  
  161. (DEFUN SP1TPLUS (L *TRIG)
  162.     (COND ((OR (NULL L) (NULL (CDR L))) L)
  163.       ((DO ((C (LIST '(RAT) 1 (EXPT 2 (f1- (LENGTH L)))))
  164.         (ANS (LIST (CAR L)))
  165.         (L (CDR L) (CDR L)))
  166.            ((NULL L) (LIST C (M+L ANS)))
  167.            (SETQ ANS 
  168.         (M+L
  169.          (MAPCAR #'(LAMBDA (Q)
  170.                 (COND ((MTIMESP Q)
  171.                    (M* (CADR Q) (SP1SINTCOS (CADDR Q) (CAR L))))
  172.                   ((SP1SINTCOS Q (CAR L)))))
  173.               ANS)))
  174.            (SETQ ANS (COND ((MPLUSP ANS) (CDR ANS)) (T (NCONS ANS))))))))
  175.  
  176. (DEFUN SP1SINTCOS (A B)
  177.   (let* ((X
  178.    NIL)( Y NIL))
  179.     (COND ((OR (ATOM A) (ATOM B)
  180.            (NOT (MEMQ (CAAR A) '(%SIN %COS %SINH %COSH)))
  181.            (NOT (MEMQ (CAAR B) '(%SIN %COS %SINH %COSH))))
  182.        (MUL3 2 A B))
  183.       ((PROG2 (SETQ X (M+ (CADR A) (CADR B)) Y (M- (CADR A) (CADR B)))
  184.           (NULL (EQ (CAAR A) (CAAR B))))
  185.        (SETQ B (IF *TRIG '(%SIN) '(%SINH)))
  186.        (OR (EQ (CAAR A) '%SIN) (EQ (CAAR A) '%SINH)
  187.            (SETQ Y (M- Y)))
  188.        (M+ (LIST B X) (LIST B Y)))
  189.       ((MEMQ (CAAR A) '(%COS %COSH))
  190.        (M+ (LIST (LIST (CAAR A)) X)
  191.            (LIST (LIST (CAAR A)) Y)))
  192.       (*TRIG
  193.        (M- (LIST '(%COS) Y) (LIST '(%COS) X)))
  194.       ((M- (LIST '(%COSH) X) (LIST '(%COSH) Y))))))
  195.  
  196. ; For COS(X)^2, TRIGBUCKET is (X (1 (COS . 2))) or, more generally, 
  197. ; (arg (numfactor-of-arg (operator . exponent)))
  198.  
  199. (DEFUN SP1ADD (E)
  200.   (let* ((N
  201.       (COND ((EQ (CAAR E) 'MEXPT)
  202.          (COND ((= (SIGNUM1 (CADDR E)) -1)
  203.             (PROG2 0 (M- (CADDR E))
  204.               (SETQ E (CONS (LIST (OLDGET (CAAADR E) 'RECIP)) (CDADR E)))))
  205.                ((PROG2 0 (CADDR E) (SETQ E (CADR E))))))
  206.         ( 1 )))( ARG
  207.             (SP1KGET (CADR E)))( BUC NIL)( LAWS HYPERLAWS))
  208.     (COND ((MEMQ (CAAR E) '(%SIN %COS %TAN %COT %SEC %CSC))
  209.        (COND ((SETQ BUC (zl-ASSOC (CDR ARG) TRIGBUCKETS))
  210.           (SETQ LAWS TRIGLAWS)
  211.           (SP1ADDBUC (CAAR E) (CAR ARG) N BUC))
  212.          ((SETQ TRIGBUCKETS
  213.             (CONS (LIST (CDR ARG) (LIST (CAR ARG) (CONS (CAAR E) N)))
  214.                   TRIGBUCKETS)))))
  215.       ((SETQ BUC (zl-ASSOC (CDR ARG) HYPERBUCKETS))
  216.        (SP1ADDBUC (CAAR E) (CAR ARG) N BUC))
  217.       ((SETQ HYPERBUCKETS
  218.          (CONS (LIST (CDR ARG) (LIST (CAR ARG) (CONS (CAAR E) N)))
  219.                HYPERBUCKETS))))))
  220.  
  221. (DEFUN SP1ADDBUC (F ARG N B)            ;FUNCTION, ARGUMENT, EXPONENT, BUCKET LIST
  222.     (COND ((AND (CDR B) (ALIKE1 ARG (CAADR B)))    ;GOES IN THIS BUCKET
  223.        (SP1PUTBUC F N (CADR B)))
  224.       ((OR (NULL (CDR B)) (GREAT (CAADR B) ARG))
  225.        (RPLACD B (CONS (LIST ARG (CONS F N)) (CDR B))))
  226.       ((SP1ADDBUC F ARG N (CDR B)))))
  227.  
  228. (DEFUN SP1PUTBUC (F N *BUC)                ;PUT IT IN THERE
  229.   (DO ((BUC *BUC (CDR BUC)))
  230.       ((NULL (CDR BUC))
  231.        (RPLACD BUC (LIST (CONS F N))))
  232.     (COND ((EQ F (CAADR BUC))                ;SAME FUNCTION
  233.        (RETURN
  234.         (RPLACD (CADR BUC) (M+ N (CDADR BUC)))))    ;SO BOOST EXPONENT
  235.       ((EQ (CAADR BUC) (OLDGET F 'RECIP))        ;RECIPROCAL FUNCTIONS
  236.        (SETQ N (M- (CDADR BUC) N))
  237.        (RETURN
  238.         (COND ((SIGNP E N) (RPLACD BUC (CDDR BUC)))
  239.           ((= (SIGNUM1 N) -1)
  240.            (RPLACA (CADR BUC) F)
  241.            (RPLACD (CADR BUC) (NEG N)))
  242.           (T (RPLACD (CADR BUC) N)))))
  243.       (T (let* ((NF    (oldGET (oldGET LAWS (CAADR BUC)) F))( M NIL))
  244.         (COND ((NULL NF))            ;NO SIMPLIFICATIONS HERE
  245.               ((EQUAL N (CDADR BUC))        ;EXPONENTS MATCH
  246.                (RPLACD BUC (CDDR BUC))
  247.                (RETURN
  248.             (SP1PUTBUC1 NF N *BUC)))    ;TO MAKE SURE IT DOESN'T OCCUR TWICE
  249.               ((EQ (SETQ M (SP1GREAT N (CDADR BUC))) 'NOMATCH))
  250.               (M (SETQ M (CDADR BUC))
  251.              (RPLACD BUC (CDDR BUC))
  252.              (SP1PUTBUC1 NF M *BUC)
  253.              (SP1PUTBUC1 F (M- N M) *BUC)
  254.              (RETURN T))
  255.               (T (RPLACD (CADR BUC) (M- (CDADR BUC) N))
  256.              (RETURN (SP1PUTBUC1 NF N *BUC)))))))))
  257.  
  258. (DEFUN SP1PUTBUC1 (F N BUC)
  259.     (COND ((NULL (CDR BUC))
  260.        (RPLACD BUC (LIST (CONS F N))))
  261.       ((EQ F (CAADR BUC))
  262.        (RPLACD (CADR BUC) (M+ N (CDADR BUC))))
  263.       ((SP1PUTBUC1 F N (CDR BUC)))))
  264.  
  265. (DEFUN SP1GREAT (X Y)
  266.   (let* ((A    NIL)( B NIL))
  267.     (COND ((MNUMP X)
  268.        (COND ((MNUMP Y) (GREAT X Y)) (T 'NOMATCH)))
  269.       ((OR (ATOM X) (ATOM Y)) 'NOMATCH)
  270.       ((AND (EQ (CAAR X) (CAAR Y))
  271.         (ALIKE (COND ((MNUMP (CADR X))
  272.                   (SETQ A (CADR X)) (CDDR X))
  273.                  (T (SETQ A 1) (CDR X)))
  274.                (COND ((MNUMP (CADR Y))
  275.                   (SETQ B (CADR Y)) (CDDR Y))
  276.                  (T (SETQ B 1) (CDR Y)))))
  277.        (GREAT A B))
  278.       (T 'NOMATCH))))
  279.  
  280. (DEFUN SP1UNTREP (B)
  281.     (MAPCAN
  282.      #'(LAMBDA (BUC)
  283.     (MAPCAR #'(LAMBDA (TERM)
  284.            (let* ((BAS         (SIMPLIFYA (LIST (LIST (CAR TERM))
  285.                       (M* (CAR B) (CAR BUC)))
  286.                 T)))
  287.             (COND ((EQUAL (CDR TERM) 1) BAS)
  288.                   ((M^ BAS (CDR TERM))))))
  289.         (CDR BUC)))
  290.      (CDR B)))
  291.  
  292. (DEFUN SP1KGET (E)            ;FINDS NUMERIC COEFFICIENTS
  293.     (OR (AND (MTIMESP E) (NUMBERP (CADR E))
  294.          (CONS (CADR E) (M*L (CDDR E))))
  295.     (CONS 1 E)))
  296.  
  297. (DEFUN SP1SINCOS (L *TRIG)
  298.     (MAPCAR #'(LAMBDA (Q) (SP1SINCOS2 (M* (CAR L) (CAR Q)) Q)) (CDR L)))
  299.  
  300. (DEFUN SP1SINCOS2 (ARG L)
  301.   (let* ((A
  302.    NIL))
  303.     (COND ((NULL (CDR L)))
  304.       ((AND
  305.         (SETQ A (MEMQ (CAADR L)
  306.               (COND ((NULL *TRIG)
  307.                  '(%SINH %COSH %SINH %CSCH %SECH %CSCH))
  308.                 ('(%SIN %COS %SIN %CSC %SEC %CSC)))))
  309.         (CDDR L))            ;THERE MUST BE SOMETHING TO MATCH TO.
  310.        (SP1SINCOS1 (CADR A) L ARG))
  311.       ((SP1SINCOS2 ARG (CDR L))))))
  312.  
  313. (DEFUN SP1SINCOS1 (S L ARG)
  314.   (let* ((G
  315.    NIL)( E 1))
  316.     (DO ((LL (CDR L) (CDR LL)))
  317.     ((NULL (CDR LL)) T)
  318.     (COND ((EQ S (CAADR LL))
  319.            (SETQ ARG (M* 2 ARG))
  320.            (COND (*TRIG
  321.               (COND ((MEMQ S '(%SIN %COS))
  322.                  (SETQ S '%SIN))
  323.                 ((SETQ S '%CSC E -1))))
  324.              (T 
  325.               (COND ((MEMQ S '(%SINH %COSH))
  326.                  (SETQ S '%SINH))
  327.                 ((SETQ S '%CSCH E -1)))))
  328.            (COND ((ALIKE1 (CDADR LL) (CDADR L))
  329.               (SP1ADDTO S ARG (CDADR L))
  330.               (SETQ *LIN (CONS (M* E (CDADR L)) *LIN))
  331.               (RPLACD LL (CDDR LL))    ;;;MUST BE IN THIS ORDER!!
  332.               (RPLACD L (CDDR L))
  333.               (RETURN T))
  334.              ((EQ (SETQ G (SP1GREAT (CDADR L) (CDADR LL))) 'NOMATCH))
  335.              ((NULL G)
  336.               (RPLACD (CADR LL) (M- (CDADR LL) (CDADR L)))
  337.               (SP1ADDTO S ARG (CDADR L))
  338.               (SETQ *LIN (CONS (M* E (CDADR L)) *LIN))
  339.               (RPLACD L (CDDR L))
  340.               (RETURN T))
  341.              (T
  342.               (RPLACD (CADR L) (M- (CDADR L) (CDADR LL)))
  343.               (SP1ADDTO S ARG (CDADR LL))
  344.               (SETQ *LIN (CONS (M* E (CDADR LL)) *LIN))
  345.               (RPLACD LL (CDDR LL))
  346.               (RETURN T))))))))
  347.  
  348. (DEFUN SP1ADDTO (FN ARG EXP)
  349.     (SETQ ARG (LIST (LIST FN) ARG))
  350.     (SP1ADD (COND ((EQUAL EXP 1) ARG) (T (M^ ARG EXP)))))
  351.  
  352. (SETQ SC^NDISP '((%SIN . SIN^N) (%COS . COS^N) (%SINH . SINH^N) (%COSH . COSH^N)))
  353.  
  354. (DEFUN SP1EXPT (B E)
  355.     (COND ((MEXPTP B)
  356.        (SP1EXPT (CADR B) (M* E (CADDR B))))
  357.       ((AND (NULL (TRIGFP B)) (FREE E VAR))
  358.        (M^ B E))
  359.       ((EQUAL B '$%E)
  360.        (SP1EXPT2 E))
  361.       ((AND (NULL (EQ VAR '*NOVAR)) (FREE B VAR))
  362.        (SP1EXPT2 (M* (LIST '(%LOG) B) E)))
  363.       ((MEMQ (CAAR B) '(%SIN %COS %TAN %COT %SEC %CSC
  364.                 %SINH %COSH %TANH %COTH %SECH %CSCH))
  365.        (COND ((= (SIGNUM1 E) -1)
  366.           (SP1EXPT (LIST (LIST (oldGET (CAAR B) 'RECIP)) (CADR B))
  367.                (NEG E)))
  368.          ((AND (SIGNP G E)
  369.                (MEMQ (CAAR B) '(%SIN %COS %SINH %COSH)))
  370.           (FUNCALL (CDR (ASSQ (CAAR B) SC^NDISP)) E (CADR B)))
  371.          ((M^ B E))))
  372.       ((M^ B E))))
  373.  
  374. (DEFUN SP1EXPT2 (E)
  375.     (let* ((ANS
  376.      NIL)( FR NIL)( EXP NIL))
  377.     (SETQ ANS (M2 E '((MPLUS) ((COEFFPP) (FR FREEVAR))
  378.                   ((COEFFPP) (EXP TRUE)))
  379.             NIL)
  380.           FR (CDR (ASSQ 'FR ANS))
  381.           EXP (CDR (ASSQ 'EXP ANS)))
  382.     (COND ((EQUAL FR 0)
  383.            (M^ '$%E EXP))
  384.           ((M* (M^ '$%E FR) (M^ '$%E EXP))))))
  385.  
  386. (SETQ *SP1LOGF NIL)
  387.  
  388. (DEFUN SP1LOG (E)
  389.     (COND ((OR *TRIGRED (ATOM E) (FREE E VAR))
  390.        (LIST '(%LOG) E))
  391.       ((EQ (CAAR E) 'MPLUS)
  392.        (let* ((EXP
  393.         (M1- E))( *A NIL)( *N NIL))
  394.         (COND ((SMONO EXP VAR)
  395.                (LIST '(%LOG) E))
  396.               (*SP1LOGF (SP1LOG2 E))
  397.               ((let* ((*SP1LOGF
  398.             T)) (SP1LOG ($FACTOR E)))))))
  399.       ((EQ (CAAR E) 'MTIMES)
  400.        (SP1 (M+L (MAPCAR 'SP1LOG (CDR E)))))
  401.       ((EQ (CAAR E) 'MEXPT)
  402.        (SP1 (M* (CADDR E) (LIST '(%LOG) (CADR E)))))
  403.       ((SP1LOG2 E))))
  404.  
  405. (DEFUN SP1LOG2 (E)
  406.   (AND $VERBOSE
  407.        (PROG2 (MTELL "Can't expand ")
  408.           (SHOW-EXP (LIST '(%LOG) E))
  409.           (MTELL "So we'll try again after applying the rule:~2%~M~%~%"
  410.              (LIST '(MLABLE) NIL
  411.                (OUT-OF
  412.                 (LIST '(MEQUAL)
  413.                   (LIST '(%LOG) E)
  414.                   (LIST '(%INTEGRATE)
  415.                     (LIST '(MQUOTIENT)
  416.                           (LIST '(%DERIVATIVE) E VAR 1)
  417.                           E)
  418.                     VAR)))))))
  419.   (LIST '(%INTEGRATE)
  420.     (SP1 ($RATSIMP (LIST '(MTIMES) (SDIFF E VAR) (LIST '(MEXPT) E -1))))
  421.     VAR))
  422.  
  423. (DEFUN SP1TRIG (E)
  424.     (COND ((ATOM (CADR E)) (SIMPLIFY E))
  425.       ((EQ (CAAADR E) (oldGET (CAAR E) '$INVERSE)) (SP1 (CADADR E)))
  426.       ((EQ (CAAADR E) (oldGET (oldGET (CAAR E) 'RECIP) '$INVERSE))
  427.        (SP1 (M// (CADADR E))))
  428.       ((AND (NULL *TRIGRED) (NULL *NOEXPAND) (EQ (CAAADR E) 'MPLUS))
  429.        (SP1TRIGEX E))
  430.       ( E )))
  431.  
  432. (DEFUN SP1TRIGEX (E)
  433.     (let* ((ANS
  434.      NIL)( FR NIL)( EXP NIL))
  435.     (SETQ ANS (M2 (CADR E) '((MPLUS) ((COEFFPP) (FR FREEVAR))
  436.                   ((COEFFPP) (EXP TRUE)))
  437.             NIL)
  438.           FR (CDR (ASSQ 'FR ANS))
  439.           EXP (CDR (ASSQ 'EXP ANS)))
  440.     (COND ((SIGNP E FR)
  441.            (SETQ FR (CADR EXP)
  442.              EXP (COND ((CDDDR EXP)
  443.                 (CONS (CAR EXP) (CDDR EXP)))
  444.                    ((CADDR EXP))))))
  445.     (COND ((OR (EQUAL FR 0)
  446.            (NULL (MEMQ (CAAR E) '(%SIN %COS %SINH %COSH))))
  447.            E)
  448.           ((EQ (CAAR E) '%SIN)
  449.            (M+ (M* (SP1TRIG (LIST '(%SIN) EXP))
  450.                (SP1TRIG (LIST '(%COS) FR)))
  451.            (M* (SP1TRIG (LIST '(%COS) EXP))
  452.                (SP1TRIG (LIST '(%SIN) FR)))))
  453.           ((EQ (CAAR E) '%COS)
  454.            (M- (M* (SP1TRIG (LIST '(%COS) EXP))
  455.                (SP1TRIG (LIST '(%COS) FR)))
  456.            (M* (SP1TRIG (LIST '(%SIN) EXP))
  457.                (SP1TRIG (LIST '(%SIN) FR)))))
  458.           ((EQ (CAAR E) '%SINH)
  459.            (M+ (M* (SP1TRIG (LIST '(%SINH) EXP))
  460.                (SP1TRIG (LIST '(%COSH) FR)))
  461.            (M* (SP1TRIG (LIST '(%COSH) EXP))
  462.                (SP1TRIG (LIST '(%SINH) FR)))))
  463.           ((EQ (CAAR E) '%COSH)
  464.            (M+ (M* (SP1TRIG (LIST '(%COSH) EXP))
  465.                (SP1TRIG (LIST '(%COSH) FR)))
  466.            (M* (SP1TRIG (LIST '(%SINH) EXP))
  467.                (SP1TRIG (LIST '(%SINH) FR))))))))
  468.  
  469. (DEFUN SP1ATRIG (FN EXP)
  470.     (COND ((ATOM EXP)
  471.        (SP1ATRIG2 FN EXP))
  472.       ((EQ FN (OLDGET (CADR EXP) '$INVERSE))
  473.        (SP1 (CADR EXP)))
  474.       (T (SP1ATRIG2 FN EXP))))
  475.  
  476. (DEFUN SP1ATRIG2 (FN EXP)
  477.      (COND ((MEMQ FN '(%COT %SEC %CSC %COTH %SECH %CSCH))
  478.         (SETQ EXP (SP1 (M// EXP))
  479.           FN (CDR (ASSQ FN '((%ACOT . %ATAN) (%ASEC . %ACOS) (%ACSC . %ASIN)
  480.                      (%ACOTH . %ATANH) (%ASECH . %ACOSH) (%ACSCH . %ASINH)))))))
  481.      (COND ((AND (NULL *TRIGRED)
  482.          (MEMQ FN '(%ACOS %ACOSH)))
  483.         (M+ HALF%PI (LIST
  484.              (LIST (CDR (ASSQ FN '((%ACOS . %ASIN) (%ACOSH . %ASINH)))))
  485.                  EXP)))
  486.        ((LIST (LIST FN) EXP))))
  487.  
  488. (DEFUN SIN^N (%N V)
  489.             (SC^N %N V (COND ((ODDP %N) '(%SIN))('(%COS))) (NOT (ODDP %N))
  490.                 (M^ -1 (M+ (// %N 2) 'K))))
  491.  
  492. (DEFUN SINH^N (%N V)
  493.        (M- (SC^N %N V (COND ((ODDP %N) '(%SINH))
  494.                   ('(%COSH)))
  495.          (NOT (ODDP %N))
  496.          (M^ -1 (M+ (// %N 2) 'K)))))
  497.  
  498. (DEFUN COS^N (%N V) (SC^N %N V '(%COS) (NOT (ODDP %N)) 1))
  499.  
  500. (DEFUN COSH^N (%N V) (SC^N %N V '(%COSH) (NOT (ODDP %N)) 1))
  501.  
  502. (DEFUN SC^N (%N V FN FL COEF)
  503.     (COND ((MINUSP %N) (MERROR "Bug in TRIGREDUCE.  Please report.")))
  504.     (M* (LIST '(RAT) 1 (EXPT 2 %N))
  505.     (M+ (COND (FL (LIST '(%BINOMIAL) %N (// %N 2))) (T 0))
  506.         (MAXIMA-SUBSTITUTE V 'TRIG-VAR
  507.             (DOSUM (M+ (M* 2
  508.                        (LIST '(%BINOMIAL) %N 'K)
  509.                        COEF
  510.                        (LIST FN (M* 'TRIG-VAR
  511.                             (M+ %N (M* -2 'K))))))
  512.             'K 0 (// (f1- %N) 2) T)))))
  513.  
  514.